      MODULE GWFETSMODULE
        INTEGER,SAVE,POINTER   ::NETSOP,IETSCB,NPETS,IETSPF,NETSEG
        INTEGER,      SAVE, DIMENSION(:,:),   POINTER ::IETS
        REAL,         SAVE, DIMENSION(:,:),   POINTER ::ETSR
        REAL,         SAVE, DIMENSION(:,:),   POINTER ::ETSX
        REAL,         SAVE, DIMENSION(:,:),   POINTER ::ETSS
        REAL,         SAVE, DIMENSION(:,:,:), POINTER ::PXDP
        REAL,         SAVE, DIMENSION(:,:,:), POINTER ::PETM
      TYPE GWFETSTYPE
        INTEGER, POINTER   ::NETSOP,IETSCB,NPETS,IETSPF,NETSEG
        INTEGER,       DIMENSION(:,:),   POINTER ::IETS
        REAL,          DIMENSION(:,:),   POINTER ::ETSR
        REAL,          DIMENSION(:,:),   POINTER ::ETSX
        REAL,          DIMENSION(:,:),   POINTER ::ETSS
        REAL,          DIMENSION(:,:,:), POINTER ::PXDP
        REAL,          DIMENSION(:,:,:), POINTER ::PETM
      END TYPE
      TYPE(GWFETSTYPE), SAVE :: GWFETSDAT(10)
      END MODULE GWFETSMODULE

      SUBROUTINE GWF2ETS7AR(IN,IGRID)
C     ******************************************************************
C     ALLOCATE ARRAY STORAGE FOR EVAPOTRANSPIRATION SEGMENTS AND READ
C     PARAMETER DEFINITIONS
C     Modified 11/21/2001 to support parameter instances - ERB
C     Modified 8/17/2009 to support NETSOP=3 - ERB
C     ******************************************************************
C
C        SPECIFICATIONS:
C     ------------------------------------------------------------------
      USE GLOBAL,       ONLY:IOUT,NCOL,NROW,IFREFM
      USE GWFETSMODULE, ONLY:NETSOP,IETSCB,NPETS,IETSPF,NETSEG,
     1                       IETS,ETSR,ETSX,ETSS,PXDP,PETM
C
      CHARACTER*4 PTYP
      CHARACTER*200 LINE
C     ------------------------------------------------------------------
  500 FORMAT(1X,/
     &1X,'ETS7 -- EVAPOTRANSPIRATION SEGMENTS PACKAGE, VERSION 7,',
     &     ' 2/28/2006',/,9X,'INPUT READ FROM UNIT ',I4)
  510 FORMAT(
     &1X,I5,' SEGMENTS DEFINE EVAPOTRANSPIRATION RATE FUNCTION')
  520 FORMAT(' EVAPOTRANSPIRATION RATE FUNCTION IS LINEAR')
  530 FORMAT(
     &' ERROR: EVAPOTRANSPIRATION RATE FUNCTION MUST CONTAIN AT',/,
     &' LEAST ONE SEGMENT -- STOP EXECUTION (GWF2ETS7ALP)')
  540 FORMAT(1X,'ILLEGAL ET OPTION CODE. SIMULATION ABORTING')
  550 FORMAT(1X,'OPTION 1 -- EVAPOTRANSPIRATION FROM TOP LAYER')
  560 FORMAT(1X,'OPTION 2 -- EVAPOTRANSPIRATION FROM ONE SPECIFIED',
     &   ' NODE IN EACH VERTICAL COLUMN')
  564 FORMAT(1X,'OPTION 3 -- EVAPOTRANSPIRATION FROM UPPERMOST ACTIVE ',
     &   'CELL')
  570 FORMAT(1X,'CELL-BY-CELL FLOWS WILL BE SAVED ON UNIT ',I4)
  580 FORMAT(1X,I10,' ELEMENTS IN RX ARRAY ARE USED BY ETS')
  590 FORMAT(1X,I10,' ELEMENTS IN IR ARRAY ARE USED BY ETS')
C
      ALLOCATE (NETSOP,IETSCB,NPETS,IETSPF,NETSEG)
C
C1------IDENTIFY PACKAGE.
      IETSPF=20
      IF(LSTCHK(3)) THEN
        WRITE(IOUT,500)IN
      ENDIF
C
C     READ COMMENT LINE(S) (ITEM 0)
      CALL URDCOM(IN,IOUT,LINE)
C
C2------READ ET OPTION (NETSOP), UNIT OR FLAG FOR CELL-BY-CELL FLOW
C       TERMS (IETSCB), NUMBER OF PARAMETERS (NPETS), AND NUMBER OF
C       SEGMENTS (NETSEG) (ITEM 1)
      IF (IFREFM.EQ.0) THEN
        READ(LINE,'(4I10)') NETSOP,IETSCB,NPETS,NETSEG
      ELSE
        LLOC=1
        CALL URWORD(LINE,LLOC,ISTART,ISTOP,2,NETSOP,R,IOUT,IN)
        CALL URWORD(LINE,LLOC,ISTART,ISTOP,2,IETSCB,R,IOUT,IN)
        CALL URWORD(LINE,LLOC,ISTART,ISTOP,2,NPETS,R,IOUT,IN)
        CALL URWORD(LINE,LLOC,ISTART,ISTOP,2,NETSEG,R,IOUT,IN)
      ENDIF
C
C3------CHECK TO SEE THAT ET OPTION IS LEGAL.
      IF (NETSOP.GE.1 .AND. NETSOP.LE.3) GO TO 10
C
C3A-----OPTION IS ILLEGAL -- PRINT A MESSAGE & ABORT SIMULATION.
      IF(LSTCHK(1)) THEN
        WRITE(IOUT,540)
      ENDIF
      CALL USTOP(' ')
C
C4------OPTION IS LEGAL -- PRINT THE OPTION CODE.
   10 CONTINUE
      IF(LSTCHK(3)) THEN
        IF (NETSOP.EQ.1) WRITE(IOUT,550)
      ENDIF
      IF(LSTCHK(3)) THEN
        IF (NETSOP.EQ.2) WRITE(IOUT,560)
      ENDIF
      IF(LSTCHK(3)) THEN
        IF (NETSOP.EQ.3) WRITE(IOUT,564) ! Add option 3 ERB 5/8/2009
      ENDIF
C
C5------IF CELL-BY-CELL FLOWS ARE TO BE SAVED, THEN PRINT UNIT NUMBER.
      IF(LSTCHK(3)) THEN
      IF (IETSCB.GT.0)   WRITE(IOUT,570) IETSCB
      ENDIF
C
C-----PRINT NUMBER OF PARAMETERS TO BE USED
      CALL UPARARRAL(-1,IOUT,LINE,NPETS)
C
C     PRINT MESSAGE IDENTIFYING NUMBER OF SEGMENTS IN ET VS. HEAD CURVE
      IF(NETSEG.GT.1) THEN
        IF(LSTCHK(3)) THEN
          WRITE(IOUT,510) NETSEG
        ENDIF
      ELSEIF (NETSEG.EQ.1) THEN
        IF(LSTCHK(3)) THEN
          WRITE(IOUT,520)
        ENDIF
      ELSE
        IF(LSTCHK(3)) THEN
          WRITE(IOUT,530)
        ENDIF
        CALL USTOP(' ')
      ENDIF
C
C6------ALLOCATE SPACE FOR THE ARRAYS ETSR, ETSX, ETSS, PXDP, AND PETM.
      ALLOCATE (ETSR(NCOL,NROW))
      ALLOCATE (ETSX(NCOL,NROW))
      ALLOCATE (ETSS(NCOL,NROW))
      IF( NETSEG.GT.1) THEN
        ALLOCATE (PXDP(NCOL,NROW,NETSEG))
        ALLOCATE (PETM(NCOL,NROW,NETSEG))
      ELSE
        ALLOCATE (PXDP(1,1,1))
        ALLOCATE (PETM(1,1,1))
      END IF
C
C7------ALLOCATE SPACE FOR LAYER INDICATOR ARRAY (IETS) EVEN IF ET
C7------OPTION IS NOT 2.
      ALLOCATE (IETS(NCOL,NROW))
C
C-------READ NAMED PARAMETERS
      IF(LSTCHK(3)) THEN
        WRITE(IOUT,50) NPETS
      ENDIF
   50 FORMAT(1X,//1X,I5,' Evapotranspiration segments parameters')
      IF (NPETS.GT.0) THEN
        DO100 K=1,NPETS
C         UPARARRRP READS PARAMETER NAME AND DEFINITION (ITEMS 2 AND 3)
          CALL UPARARRRP(IN,IOUT,N,0,PTYP,1,1,0)
          IF(PTYP.NE.'ETS') THEN
            IF(LSTCHK(1)) THEN
              WRITE(IOUT,57)
            ENDIF
   57       FORMAT(1X,'Parameter type must be ETS')
            CALL USTOP(' ')
          ENDIF
  100   CONTINUE
      ENDIF
C
C8------RETURN
      CALL SGWF2ETS7PSV(IGRID)
      RETURN
      END
      SUBROUTINE GWF2ETS7RP(IN,IGRID)
C     ******************************************************************
C     READ EVAPOTRANSPIRATION DATA, AND PERFORM SUBSTITUTION USING
C     PARAMETER VALUES IF ETS PARAMETERS ARE DEFINED
C     ******************************************************************
C
C        SPECIFICATIONS:
C     ------------------------------------------------------------------
      USE GLOBAL,       ONLY:NCOL,NROW,IOUT,DELR,DELC,IFREFM
      USE GWFETSMODULE, ONLY:NETSOP,NETSEG,NPETS,IETSPF,
     1                       IETS,ETSR,ETSX,ETSS,PXDP,PETM
C
      CHARACTER*24 ANAME(6)
      DATA ANAME(1) /'   ET LAYER INDEX (IETS)'/
      DATA ANAME(2) /'       ET SURFACE (ETSS)'/
      DATA ANAME(3) /' EVAPOTRANS. RATE (ETSR)'/
      DATA ANAME(4) /' EXTINCTION DEPTH (ETSX)'/
      DATA ANAME(5) /'EXTINCT. DEP. PROPORTION'/
      DATA ANAME(6) /'      ET RATE PROPORTION'/
C     ------------------------------------------------------------------
      CALL SGWF2ETS7PNT(IGRID)
C
C1------READ FLAGS SHOWING WHETHER DATA FROM PREVIOUS STRESS PERIOS ARE
C       TO BE REUSED.
      IF (NETSEG.GT.1) THEN
        IF(IFREFM.EQ.0) THEN
          READ(IN,'(5I10)') INETSS,INETSR,INETSX,INIETS,INSGDF
        ELSE
          READ(IN,*) INETSS,INETSR,INETSX,INIETS,INSGDF
        ENDIF
      ELSE
        IF(NETSOP.EQ.2) THEN
          IF(IFREFM.EQ.0) THEN
            READ(IN,'(4I10)') INETSS,INETSR,INETSX,INIETS
          ELSE
            READ(IN,*) INETSS,INETSR,INETSX,INIETS
          ENDIF
        ELSE
          IF(IFREFM.EQ.0) THEN
            READ(IN,'(3I10)') INETSS,INETSR,INETSX
          ELSE
            READ(IN,*) INETSS,INETSR,INETSX
          ENDIF
        ENDIF
      ENDIF
C
C2------TEST INETSS TO SEE WHERE SURFACE ELEVATION COMES FROM.
      IF (INETSS.LT.0) THEN
C2A------IF INETSS<0 THEN REUSE SURFACE ARRAY FROM LAST STRESS PERIOD
        IF(LSTCHK(3)) THEN
          WRITE(IOUT,10)
        ENDIF
   10   FORMAT(1X,/1X,'REUSING ETSS FROM LAST STRESS PERIOD')
      ELSE
C3-------IF INETSS=>0 THEN CALL MODULE U2DREL TO READ SURFACE.
        CALL U2DREL(ETSS,ANAME(2),NROW,NCOL,0,IN,IOUT)
      ENDIF
C
C4------TEST INETSR TO SEE WHERE MAX ET RATE COMES FROM.
      IF (INETSR.LT.0) THEN
C4A-----IF INETSR<0 THEN REUSE MAX ET RATE.
        IF(LSTCHK(3)) THEN
          WRITE(IOUT,20)
        ENDIF
   20   FORMAT(1X,/1X,'REUSING ETSR FROM LAST STRESS PERIOD')
      ELSE
C5------IF INETSR=>0 CALL MODULE U2DREL TO READ MAX ET RATE.
        IF(NPETS.EQ.0) THEN
          CALL U2DREL(ETSR,ANAME(3),NROW,NCOL,0,IN,IOUT)
        ELSE
C    INETSR is the number of parameters to use this stress period
          CALL PRESET('ETS')
          IF(LSTCHK(3)) THEN
            WRITE(IOUT,30)
          ENDIF
   30     FORMAT(1X,///1X,
     &        'ETSR array defined by the following parameters:')
          IF (INETSR.EQ.0) THEN
            IF(LSTCHK(1)) THEN
              WRITE(IOUT,35)
            ENDIF
   35       FORMAT(' ERROR: When parameters are defined for the ETS',
     &      ' Package, at least one parameter',/,' must be specified',
     &      ' each stress period -- STOP EXECUTION (GWF2ETS7RPSS)')
            CALL USTOP(' ')
          ENDIF
          CALL UPARARRSUB2(ETSR,NCOL,NROW,0,INETSR,IN,IOUT,'ETS',
     &                     ANAME(3),'ETS',IETSPF)
        ENDIF
C
C6------MULTIPLY MAX ET RATE BY CELL AREA TO GET VOLUMETRIC RATE
        DO 50 IR=1,NROW
          DO 40 IC=1,NCOL
            ETSR(IC,IR)=ETSR(IC,IR)*DELR(IC)*DELC(IR)
   40     CONTINUE
   50   CONTINUE
      ENDIF
C
C7------TEST INETSX TO SEE WHERE EXTINCTION DEPTH COMES FROM
      IF (INETSX.LT.0) THEN
C7A------IF INETSX<0 REUSE EXTINCTION DEPTH FROM LAST STRESS PERIOD
        IF(LSTCHK(3)) THEN
          WRITE(IOUT,60)
        ENDIF
   60   FORMAT(1X,/1X,'REUSING ETSX FROM LAST STRESS PERIOD')
      ELSE
C8-------IF INETSX=>0 CALL MODULE U2DREL TO READ EXTINCTION DEPTH
        CALL U2DREL(ETSX,ANAME(4),NROW,NCOL,0,IN,IOUT)
      ENDIF
C
C9------IF OPTION(NETSOP) IS 2 THEN WE NEED AN INDICATOR ARRAY.
      IF (NETSOP.EQ.2) THEN
C10------IF INIETS<0 THEN REUSE LAYER INDICATOR ARRAY.
        IF (INIETS.LT.0) THEN
          IF(LSTCHK(3)) THEN
            WRITE(IOUT,70)
          ENDIF
   70     FORMAT(1X,/1X,'REUSING IETS FROM LAST STRESS PERIOD')
        ELSE
C11------IF INIETS=>0 THEN CALL MODULE U2DINT TO READ INDICATOR ARRAY.
          CALL U2DINT(IETS,ANAME(1),NROW,NCOL,0,IN,IOUT)
        ENDIF
      ENDIF
C
C12------IF ET FUNCTION IS SEGMENTED PXDP AND PETM ARRAYS ARE NEEDED.
      IF (NETSEG.GT.1) THEN
C13------IF INSGDF<0 THEN REUSE PXDP AND PETM ARRAYS.
        IF (INSGDF.LT.0) THEN
          IF(LSTCHK(3)) THEN
            WRITE(IOUT,80)
          ENDIF
   80     FORMAT(1X,/1X,
     &           'REUSING PXDP AND PETM FROM LAST STRESS PERIOD')
C14------IF INSGDF=>0 THEN CALL MODULE U2DREL TO READ PXDP AND PETM
C        ARRAYS.
        ELSE
          DO 90 I = 1,NETSEG-1
            IF(LSTCHK(3)) THEN
              WRITE(IOUT,100) I
            ENDIF
            CALL U2DREL(PXDP(:,:,I),ANAME(5),NROW,NCOL,0,IN,IOUT)
            CALL U2DREL(PETM(:,:,I),ANAME(6),NROW,NCOL,0,IN,IOUT)
   90     CONTINUE
        ENDIF
      ENDIF
  100 FORMAT(/,' PXDP AND PETM ARRAYS FOR INTERSECTION ',I4,
     &' OF HEAD/ET RELATION:')
C
C15-----RETURN
      RETURN
      END
      SUBROUTINE GWF2ETS7FM(IGRID)
C     ******************************************************************
C        ADD EVAPOTRANSPIRATION TO RHS AND HCOF
C     ******************************************************************
C
C        SPECIFICATIONS:
C     ------------------------------------------------------------------
      USE GLOBAL,       ONLY:NCOL,NROW,NLAY,RHS,HCOF,IBOUND,HNEW
      USE GWFETSMODULE, ONLY:NETSOP,NETSEG,IETS,ETSR,ETSX,ETSS,PXDP,PETM
C
      DOUBLE PRECISION HH, SS, XX, DD, PXDP1, PXDP2
C     ------------------------------------------------------------------
      CALL SGWF2ETS7PNT(IGRID)
C
C1------PROCESS EACH HORIZONTAL CELL LOCATION
      DO 30 IR=1,NROW
        DO 20 IC=1,NCOL
C
          IF (NETSOP.EQ.1) THEN
C2----------SET THE LAYER INDEX EQUAL TO 1      .
            IL=1
          ELSEIF (NETSOP.EQ.2) THEN
C3----------GET LAYER INDEX FROM IETS ARRAY
            IL=IETS(IC,IR)
            IF (IL.EQ.0) GO TO 20
          ELSEIF (NETSOP.EQ.3) THEN
C3A---------FIND UPPERMOST ACTIVE CELL
            IL = 1 ! If stack is inactive, this is the default
            FINDFIRST: DO ILQ=1,NLAY
              IF (IBOUND(IC,IR,ILQ).NE.0) THEN
                IL = ILQ
                EXIT FINDFIRST
              ENDIF
            ENDDO FINDFIRST
          ENDIF
C
C4------IF THE CELL IS EXTERNAL IGNORE IT.
          IF (IBOUND(IC,IR,IL).GT.0) THEN
            C=ETSR(IC,IR)
            S=ETSS(IC,IR)
            SS=S
            HH=HNEW(IC,IR,IL)
C
C5------IF HEAD IN CELL IS GREATER THAN OR EQUAL TO ETSS, ET IS CONSTANT
            IF(HH.GE.SS) THEN
C
C5A-----SUBTRACT -ETSR FROM RHS
              RHS(IC,IR,IL)=RHS(IC,IR,IL) + C
            ELSE
C
C6------IF DEPTH TO WATER>=EXTINCTION DEPTH THEN ET IS 0
              DD=SS-HH
              X=ETSX(IC,IR)
              XX=X
              IF (DD.LT.XX) THEN
C7------VARIABLE RANGE. ADD ET TERMS TO BOTH RHS AND HCOF.
C
                IF (NETSEG.GT.1) THEN
C                 DETERMINE WHICH SEGMENT APPLIES BASED ON HEAD, AND
C                 CALCULATE TERMS TO ADD TO RHS AND HCOF
C
C                 SET PROPORTIONS CORRESPONDING TO ETSS ELEVATION
                  PXDP1 = 0.0
                  PETM1 = 1.0
                  DO 10 ISEG = 1,NETSEG
C                   SET PROPORTIONS CORRESPONDING TO LOWER END OF
C                   SEGMENT
                    IF (ISEG.LT.NETSEG) THEN
                      PXDP2 = PXDP(IC,IR,ISEG)
                      PETM2 = PETM(IC,IR,ISEG)
                    ELSE
                      PXDP2 = 1.0
                      PETM2 = 0.0
                    ENDIF
                    IF (DD.LE.PXDP2*XX) THEN
C                     HEAD IS IN DOMAIN OF THIS SEGMENT
                      GOTO 15
                    ENDIF
C                   PROPORTIONS AT LOWER END OF SEGMENT WILL BE FOR
C                   UPPER END OF SEGMENT NEXT TIME THROUGH LOOP
                    PXDP1 = PXDP2
                    PETM1 = PETM2
   10             CONTINUE
   15             CONTINUE
C                 CALCULATE TERMS TO ADD TO RHS AND HCOF BASED ON
C                 SEGMENT THAT APPLIES AT HEAD ELEVATION
                  THCOF = -(PETM1-PETM2)*C/((PXDP2-PXDP1)*X)
                  TRHS = THCOF*(S-PXDP1*X) + PETM1*C
                ELSE
C                 CALCULATE TERMS TO ADD TO RHS AND HCOF BASED ON SIMPLE
C                 LINEAR RELATION OF ET VS. HEAD
                  TRHS = C-C*S/X
                  THCOF = -C/X
                ENDIF
                RHS(IC,IR,IL)=RHS(IC,IR,IL)+TRHS
                HCOF(IC,IR,IL)=HCOF(IC,IR,IL)+THCOF
              ENDIF
            ENDIF
          ENDIF
   20   CONTINUE
   30 CONTINUE
C
C8------RETURN
      RETURN
      END
      SUBROUTINE GWF2ETS7BD(KSTP,KPER,IGRID)
C     ******************************************************************
C     CALCULATE VOLUMETRIC BUDGET FOR EVAPOTRANSPIRATION SEGMENTS
C     ******************************************************************
C
C        SPECIFICATIONS:
C     ------------------------------------------------------------------
      USE GLOBAL ,      ONLY: IOUT,HNEW,IBOUND,BUFF,NCOL,NROW,NLAY
      USE GWFBASMODULE, ONLY: MSUM,VBNM,VBVL,PERTIM,TOTIM,DELT,ICBCFL
      USE GWFETSMODULE, ONLY: NETSOP,IETSCB,NETSEG,IETS,ETSR,ETSX,ETSS,
     1                        PXDP,PETM
C
      DOUBLE PRECISION RATOUT, QQ, HH, SS, DD, XX, HHCOF, RRHS,
     &                 PXDP1, PXDP2
      CHARACTER*16 TEXT
      DATA TEXT /'     ET SEGMENTS'/
C     ------------------------------------------------------------------
      CALL SGWF2ETS7PNT(IGRID)
C
C1------CLEAR THE RATE ACCUMULATOR.
      ZERO=0.
      RATOUT=ZERO
C
C2------SET CELL-BY-CELL BUDGET SAVE FLAG (IBD) AND CLEAR THE BUFFER.
      IBD=0
      IF(IETSCB.GT.0) IBD=ICBCFL
      DO 30 IL=1,NLAY
        DO 20 IR=1,NROW
          DO 10 IC=1,NCOL
            BUFF(IC,IR,IL)=ZERO
   10     CONTINUE
   20   CONTINUE
   30 CONTINUE
C
C3------PROCESS EACH HORIZONTAL CELL LOCATION.
      DO 70 IR=1,NROW
        DO 60 IC=1,NCOL
C
          IF (NETSOP.EQ.1) THEN
C2----------SET THE LAYER INDEX EQUAL TO 1      .
            IL=1
          ELSEIF (NETSOP.EQ.2) THEN
C3----------GET LAYER INDEX FROM IETS ARRAY
            IL=IETS(IC,IR)
            IF (IL.EQ.0) GO TO 60
          ELSEIF (NETSOP.EQ.3) THEN
C3A---------FIND UPPERMOST ACTIVE CELL
            IL = 1 ! If stack is inactive, this is the default
            FINDFIRST: DO ILQ=1,NLAY
              IF (IBOUND(IC,IR,ILQ).NE.0) THEN
                IL = ILQ
                EXIT FINDFIRST
              ENDIF
            ENDDO FINDFIRST
            IETS(IC,IR) = IL
          ENDIF
C
C6------IF CELL IS EXTERNAL THEN IGNORE IT.
          IF (IBOUND(IC,IR,IL).GT.0) THEN
            C=ETSR(IC,IR)
            S=ETSS(IC,IR)
            SS=S
            HH=HNEW(IC,IR,IL)
C
C7------IF HEAD IN CELL => ETSS,SET Q=MAX ET RATE.
            IF (HH.GE.SS) THEN
             QQ=-C
            ELSE
C
C8------IF DEPTH=>EXTINCTION DEPTH, ET IS 0.
              X=ETSX(IC,IR)
              XX=X
              DD=SS-HH
              IF (DD.LT.XX) THEN
C9------VARIABLE RANGE.  CALCULATE Q DEPENDING ON NUMBER OF SEGMENTS
C
                IF (NETSEG.GT.1) THEN
C                 DETERMINE WHICH SEGMENT APPLIES BASED ON HEAD, AND
C                 CALCULATE TERMS TO ADD TO RHS AND HCOF
C
C                 SET PROPORTIONS CORRESPONDING TO ETSS ELEVATION
                  PXDP1 = 0.0
                  PETM1 = 1.0
                  DO 40 ISEG = 1,NETSEG
C                   SET PROPORTIONS CORRESPONDING TO LOWER END OF
C                   SEGMENT
                    IF (ISEG.LT.NETSEG) THEN
                      PXDP2 = PXDP(IC,IR,ISEG)
                      PETM2 = PETM(IC,IR,ISEG)
                    ELSE
                      PXDP2 = 1.0
                      PETM2 = 0.0
                    ENDIF
                    IF (DD.LE.PXDP2*XX) THEN
C                     HEAD IS IN DOMAIN OF THIS SEGMENT
                      GOTO 50
                    ENDIF
C                   PROPORTIONS AT LOWER END OF SEGMENT WILL BE FOR
C                   UPPER END OF SEGMENT NEXT TIME THROUGH LOOP
                    PXDP1 = PXDP2
                    PETM1 = PETM2
   40             CONTINUE
   50             CONTINUE
C9------CALCULATE ET RATE BASED ON SEGMENT THAT APPLIES AT HEAD
C9------ELEVATION
                  HHCOF = -(PETM1-PETM2)*C/((PXDP2-PXDP1)*X)
                  RRHS = -HHCOF*(S-PXDP1*X) - PETM1*C
                ELSE
C10-----SIMPLE LINEAR RELATION.  Q=-ETSR*(HNEW-(ETSS-ETSX))/ETSX, WHICH
C10-----IS FORMULATED AS Q= -HNEW*ETSR/ETSX + (ETSR*ETSS/ETSX -ETSR).
                  HHCOF = -C/X
                  RRHS = (C*S/X) - C
                ENDIF
                QQ = HH*HHCOF + RRHS
              ELSE
                QQ = 0.0
              ENDIF
            ENDIF
C
C10-----ACCUMULATE TOTAL FLOW RATE.
            Q=QQ
            RATOUT=RATOUT-QQ
C
C11-----ADD Q TO BUFFER.
            BUFF(IC,IR,IL)=Q
          ENDIF
   60   CONTINUE
   70 CONTINUE
C
C12-----IF CELL-BY-CELL FLOW TO BE SAVED, CALL APPROPRIATE UTILITY
C12-----MODULE SAVE THEM.
      IF(IBD.EQ.1) CALL UBUDSV(KSTP,KPER,TEXT,IETSCB,BUFF,NCOL,NROW,
     &                         NLAY,IOUT)
      IF(IBD.EQ.2) CALL UBDSV3(KSTP,KPER,TEXT,IETSCB,BUFF,IETS,NETSOP,
     &                   NCOL,NROW,NLAY,IOUT,DELT,PERTIM,TOTIM,IBOUND)
C
C13-----MOVE TOTAL ET RATE INTO VBVL FOR PRINTING BY BAS1OT.
      ROUT=RATOUT
      VBVL(3,MSUM)=ZERO
      VBVL(4,MSUM)=ROUT
C
C14-----ADD ET(ET_RATE TIMES STEP LENGTH) TO VBVL.
      VBVL(2,MSUM)=VBVL(2,MSUM)+ROUT*DELT
C
C15-----MOVE BUDGET TERM LABELS TO VBNM FOR PRINT BY MODULE BAS1OT.
      VBNM(MSUM)=TEXT
C
C16-----INCREMENT BUDGET TERM COUNTER.
      MSUM=MSUM+1
C
C17-----RETURN.
      RETURN
      END
      SUBROUTINE GWF2ETS7DA(IGRID)
C  Deallocate ETS MEMORY
      USE GWFETSMODULE
C
        CALL SGWF2ETS7PNT(IGRID)
        DEALLOCATE(NETSOP)
        DEALLOCATE(IETSCB)
        DEALLOCATE(NPETS)
        DEALLOCATE(IETSPF)
        DEALLOCATE(NETSEG)
        DEALLOCATE(IETS)
        DEALLOCATE(ETSR)
        DEALLOCATE(ETSX)
        DEALLOCATE(ETSS)
        DEALLOCATE(PXDP)
        DEALLOCATE(PETM)
C
      RETURN
      END
      SUBROUTINE SGWF2ETS7PNT(IGRID)
C  Change ETS data to a different grid.
      USE GWFETSMODULE
C
        NETSOP=>GWFETSDAT(IGRID)%NETSOP
        IETSCB=>GWFETSDAT(IGRID)%IETSCB
        NPETS=>GWFETSDAT(IGRID)%NPETS
        IETSPF=>GWFETSDAT(IGRID)%IETSPF
        NETSEG=>GWFETSDAT(IGRID)%NETSEG
        IETS=>GWFETSDAT(IGRID)%IETS
        ETSR=>GWFETSDAT(IGRID)%ETSR
        ETSX=>GWFETSDAT(IGRID)%ETSX
        ETSS=>GWFETSDAT(IGRID)%ETSS
        PXDP=>GWFETSDAT(IGRID)%PXDP
        PETM=>GWFETSDAT(IGRID)%PETM
C
      RETURN
      END
      SUBROUTINE SGWF2ETS7PSV(IGRID)
C  Save ETS data for a grid.
      USE GWFETSMODULE
C
        GWFETSDAT(IGRID)%NETSOP=>NETSOP
        GWFETSDAT(IGRID)%IETSCB=>IETSCB
        GWFETSDAT(IGRID)%NPETS=>NPETS
        GWFETSDAT(IGRID)%IETSPF=>IETSPF
        GWFETSDAT(IGRID)%NETSEG=>NETSEG
        GWFETSDAT(IGRID)%IETS=>IETS
        GWFETSDAT(IGRID)%ETSR=>ETSR
        GWFETSDAT(IGRID)%ETSX=>ETSX
        GWFETSDAT(IGRID)%ETSS=>ETSS
        GWFETSDAT(IGRID)%PXDP=>PXDP
        GWFETSDAT(IGRID)%PETM=>PETM
C
      RETURN
      END
